﻿Imports System.IO
Imports System.Security.Principal

<ComClass(ClsComObjectHelper.ClassId, ClsComObjectHelper.InterfaceId, ClsComObjectHelper.EventsId)>
Public Class ClsComObjectHelper

#Region "COM GUID"
    ' 这些 GUID 提供此类的 COM 标识 
    ' 及其 COM 接口。若更改它们，则现有的
    ' 客户端将不再能访问此类。
    Public Const ClassId As String = "f7409cbc-64a0-4a77-a6ac-513a5359c9bd"
    Public Const InterfaceId As String = "8a134ded-7f2a-4446-8068-63fd1bc0d1a9"
    Public Const EventsId As String = "e4b451b0-5924-465f-a324-8174bff36c59"
#End Region

    ' 可创建的 COM 类必须具有一个不带参数的 Public Sub New() 
    ' 否则， 将不会在 
    ' COM 注册表中注册此类，且无法通过
    ' CreateObject 创建此类。
    Public Sub New()
        MyBase.New()
    End Sub


    Public ReadOnly Property AcadProgId As String
        Get
            Return "AutoCAD.Application"
        End Get
    End Property

    Public ReadOnly Property ExcelProgId As String
        Get
            Return "Excel.Application"
        End Get
    End Property
    Public ReadOnly Property WordProgId As String
        Get
            Return "Word.Application"
        End Get
    End Property

    Public ReadOnly Property OutLookProgId As String
        Get
            Return "OutLook.Application"
        End Get
    End Property

    Public Function IsRunAsAdministrator() As Boolean
        Dim current As Security.Principal.WindowsIdentity = WindowsIdentity.GetCurrent()
        Dim windowsPrincipal As New WindowsPrincipal(current)
        Return windowsPrincipal.IsInRole(WindowsBuiltInRole.Administrator)
    End Function

#Region "AutoCAD and Excel"

    ''' <summary>
    ''' 计算机\HKEY_CURRENT_USER\SOFTWARE\Autodesk\AutoCAD的curver的值
    ''' </summary>
    ''' <returns>R23.0</returns>
    Public Function GetLastLaunchedAutoCADVersion() As String
        Dim acadkey = My.Computer.Registry.CurrentUser.OpenSubKey("SOFTWARE\Autodesk\AutoCAD\")
        If acadkey IsNot Nothing Then
            Return acadkey.GetValue("CurVer").ToString()
        Else
            Return ""
        End If
    End Function

    ''' <summary>
    ''' 计算机\HKEY_CURRENT_USER\SOFTWARE\Autodesk\AutoCAD;提取全部子键
    ''' </summary>
    ''' <returns></returns>
    ''' 
    Public Function GetAutoCADVersions() As String()
        Dim rtns As New List(Of String)
        Dim acadkey = My.Computer.Registry.CurrentUser.OpenSubKey("SOFTWARE\Autodesk\AutoCAD\")
        If acadkey IsNot Nothing Then
            rtns.AddRange(acadkey.GetSubKeyNames())
        End If
        Return rtns.ToArray()
    End Function




    Public Function 获取AutoCAD的com对象(ByRef comObjects() As Object, ByRef errstr As String) As 进程信息()
        Dim objrtns As New List(Of 进程信息)

        Dim comobjs As New List(Of Object)

        Dim cadPros = Process.GetProcessesByName("acad").Where(Function(p) p.MainWindowTitle <> "").ToArray()
        If cadPros.Length = 0 Then
            errstr = "未开启cad进程"
        ElseIf cadPros.Length > 1 Then
            For Each cadPro As Process In cadPros
                Dim mWindtitle = cadPro.MainWindowTitle
                Dim fn = mWindtitle.Substring(mWindtitle.IndexOf("[") + 1, mWindtitle.Length - mWindtitle.IndexOf("[") - 1).Replace("]", "").Trim()
                Dim rtn As Object = Nothing
                If File.Exists(fn) Then
                    Try
                        rtn = GetObject(fn, Nothing).Application
                        errstr = ""
                    Catch ex As Exception
                        errstr = ex.Message
                    End Try
                Else
                    rtn = GetObject(Nothing, Me.AcadProgId)
                    If rtn IsNot Nothing Then
                        If rtn.Caption <> mWindtitle Then
                            errstr = "文件未保存到本地,无法获取本实例且该实例不是第一个启动的cad实例"
                            rtn = Nothing
                        Else
                            errstr = ""
                        End If
                    Else
                        errstr = "获取实例失败"
                    End If
                End If
                If rtn IsNot Nothing Then
                    Dim fls As New List(Of String)
                    For Each item As Object In rtn.Documents
                        fls.Add(item.FullName)
                    Next
                    Dim cadApp As New 进程信息 With {
                        .进程id = cadPro.Id,
                        .窗口句柄 = rtn.HWND,
                        .窗口标题 = rtn.Caption,
                        .打开的文档 = fls.ToArray(),
                        .程序的全路径 = cadPro.MainModule.FileName,
                        .程序名称 = cadPro.MainModule.FileVersionInfo.FileDescription,
                        .程序版本 = cadPro.MainModule.FileVersionInfo.ProductVersion}
                    objrtns.Add(cadApp)
                    comobjs.Add(rtn)
                End If
            Next
        Else
            Dim cadAppObj As Object = Nothing
            Try
                cadAppObj = GetObject(Nothing, Me.AcadProgId)
            Catch ex As Exception
                Dim progid = Me.AcadProgId + If(IsRunAsAdministrator(), "." & GetLastLaunchedAutoCADVersion().Substring(1, 2), "")
                'On Error Resume Next
                Try
                    cadAppObj = GetObject(Nothing, progid)
                Catch ex1 As Exception
                    errstr = ex1.Message
                End Try

            End Try

            If cadAppObj Is Nothing Then Return objrtns.ToArray()
            Dim fls As New List(Of String)
                For Each item As Object In cadAppObj.Documents
                    fls.Add(item.FullName)
                Next

                Dim cadApp As New 进程信息 With {
                       .进程id = cadPros(0).Id,
                       .窗口句柄 = cadAppObj.HWND,
                       .窗口标题 = cadAppObj.Caption,
                       .打开的文档 = fls.ToArray()}
                Try '32位excel无法访问此处64位进程的信息
                    cadApp.程序的全路径 = cadPros(0).MainModule.FileName
                    cadApp.程序名称 = cadPros(0).MainModule.FileVersionInfo.FileDescription
                    cadApp.程序版本 = cadPros(0).MainModule.FileVersionInfo.ProductVersion
                Catch ex As Exception
                    'errstr = ex.Message
                    cadApp.程序的全路径 = cadAppObj.FullName
                    cadApp.程序名称 = cadAppObj.Name
                    cadApp.程序版本 = cadAppObj.Version
                End Try
                comobjs.Add(cadAppObj)
                objrtns.Add(cadApp)
            End If
        comObjects = comobjs.ToArray()
        Return objrtns.ToArray()
    End Function

    ''' <summary>
    ''' 返回excel实例的信息
    ''' </summary>
    ''' <param name="comObject">返回的excel app对象</param>
    ''' <param name="errstr">错误提示信息</param>
    ''' <returns></returns>
    Public Function 获取Excel的com对象(ByRef comObject As Object, ByRef errstr As String) As 进程信息
        Dim excelPros = Process.GetProcessesByName("excel").Where(Function(p) p.MainWindowTitle <> "").ToArray()
        If excelPros.Length = 0 Then
            errstr = "未开启excel进程"
            Return Nothing
        Else
            Dim xlsAppObj As Excel.Application = GetObject(Nothing, Me.ExcelProgId)
            Dim fls As New List(Of String)
            For Each item As Excel.Workbook In xlsAppObj.Workbooks
                fls.Add(item.FullName)
            Next
            Dim xlsApp As New 进程信息 With {
                        .进程id = excelPros(0).Id,
                        .窗口句柄 = xlsAppObj.Hwnd,
                        .窗口标题 = xlsAppObj.Caption,
                        .打开的文档 = fls.ToArray(), .程序的全路径 = excelPros(0).MainModule.FileName,
                        .程序名称 = excelPros(0).MainModule.FileVersionInfo.FileDescription,
                        .程序版本 = excelPros(0).MainModule.FileVersionInfo.ProductVersion}
            errstr = ""
            comObject = xlsAppObj
            Return xlsApp
        End If
    End Function


#End Region


End Class




